home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 20 / Cream of the Crop 20 (Terry Blount) (1996).iso / comm / qhead.zip / QHEAD.PAS < prev    next >
Pascal/Delphi Source File  |  1996-07-08  |  18KB  |  589 lines
  1. PROGRAM QHead; {v1.25 - Free DOS utility: Get message headers from QWK files.}
  2. {$M 5120,0,0}  { 5k stack, no heap needed }
  3. {$N-,E- no math support needed}
  4. {$X- function calls may not be discarded}
  5. {$I- disable I/O checking (trap errors by checking IOResult)}
  6.  
  7. {===========================================================================}
  8.                        (** Global declarations ... **)
  9. {===========================================================================}
  10.  
  11. USES
  12.   DOS, ARCID;
  13.  
  14. CONST
  15.   cursorState : BYTE = 1;  {0..3}
  16.   cursorData : ARRAY [0..3] OF CHAR = (#179, #47, #196, #92);
  17.  
  18. VAR
  19.   unQWK, unARC, unARJ, unHAP, unLZH,
  20.   unPAK, unRAR, unUC2, unZIP, unZOO : PATHSTR;
  21.  
  22.   qheader, qline : string[128];
  23.   confnumb : WORD;
  24.   ExtractAll : Boolean;
  25.   QWKname : string[13];
  26.  
  27. {===========================================================================}
  28.                    (** Custom help & exit procedure ... **)
  29. {===========================================================================}
  30.  
  31. VAR SavedExitProc: POINTER;
  32. PROCEDURE cursorOn; FORWARD;
  33. FUNCTION WordToHex (i: WORD): STRING; FORWARD;
  34.  
  35. PROCEDURE CustomExit; FAR;
  36. {---- Always exit through here ----}
  37. CONST
  38.   NL = #13#10;
  39. VAR
  40.   message: STRING [79];
  41. BEGIN
  42.   ExitProc := SavedExitProc;
  43.   cursorOn;
  44.   IF (ExitCode > 0) THEN BEGIN
  45.     Writeln('QHead v1.25 - Free DOS utility: Extract message headers from QWK packets.');
  46.     WriteLn ('July 8, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
  47.     Writeln('Usage:    QHead <QWKpacket(s)> [conference]'+NL);
  48.     Writeln('Where:    "[conference]" is any valid DOS filename, with an embedded conference');
  49.     Writeln('          number.  If no number is found embedded within the filename, then');
  50.     Writeln('          *all* the conference headers in the QWK packet will be extracted.'+NL);
  51.     Writeln('Examples: QHead c:\qwks\*.qwk cnf100.hdr');
  52.     Writeln('          QHead c:\qwk\channel1.qwk ch-all.hdr');
  53.     Writeln('          QHead *.qwk  [writes all headers to "QHEAD.OUT"]'+NL);
  54.     Writeln('Note:     DOS wildcards may be used when specifying the QWKpackets.');
  55.   END;
  56.   IF ErrorAddr <> NIL THEN {If an unanticipated run-time error occured...}
  57.   BEGIN
  58.     WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
  59.     WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
  60.     WriteLn ('Code    = ', ExitCode);
  61.     ErrorAddr := NIL; {IMPORTANT!!!}
  62.   END
  63.   ELSE
  64.     IF (ExitCode IN [1..254]) THEN BEGIN
  65.       CASE ExitCode OF
  66.         1 : message := 'Invalid parameter on command line or parameter missing.';
  67.         2 : message := 'No files found.  First parameter must be a valid file specification.';
  68.         3 : message := 'The second parameter must contain a conference number.';
  69.         5 : message := 'Not enough memory to extract MESSAGES.DAT - aborting!';
  70.         6 : message := 'You cannot just specify a path, add "*.*" or "\*.*" for all files.';
  71.         7 : message := 'File handling error.  File may have been corrupted or deleted!';
  72.         ELSE  message := 'Unknown error.';
  73.       END;
  74.       WriteLn (#7, 'Error encountered (#', ExitCode, '):'); WriteLn (message);
  75.     END;
  76. END;
  77.  
  78. {===========================================================================}
  79.                       (** Supporting subroutines ... **)
  80. {===========================================================================}
  81.  
  82. FUNCTION WordToHex (i: WORD): STRING; {Convert a WORD variable to STRING}
  83. CONST
  84.   HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  85. BEGIN
  86.   WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
  87.                        HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
  88. END;
  89.  
  90. PROCEDURE CheckIO;
  91. BEGIN
  92.   IF IOResult <> 0 THEN Halt (7);
  93. END;
  94.  
  95. PROCEDURE cursorOn; ASSEMBLER; ASM
  96.   mov AH, 3; mov BH, 0; Int $10; AND CH, NOT $20; mov AH, 1; Int $10;
  97. END;
  98.  
  99. PROCEDURE cursorOff; ASSEMBLER; ASM
  100.   mov AH, 3; mov BH, 0; Int $10; OR CH, $20; mov AH, 1; Int $10;
  101. END;
  102.  
  103. PROCEDURE updateCursor;
  104. BEGIN
  105.   cursorState := Succ (cursorState) AND 3;
  106.   Write (cursorData [cursorState], ^H);
  107. END;
  108.  
  109. FUNCTION WhereX: BYTE; ASSEMBLER;
  110. (* Routine from SWAG *)
  111. ASM
  112.   MOV AH, 3     {Ask For current cursor position}
  113.   MOV BH, 0     { On page 0 }
  114.   Int 10h       { Return inFormation in DX }
  115.   Inc DL        { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
  116.   MOV AL, DL    { Return X position in AL For use in Byte Result }
  117. END;
  118.  
  119. FUNCTION WhereY: BYTE; ASSEMBLER;
  120. (* Routine from SWAG *)
  121. ASM
  122.   MOV AH, 3    {Ask For current cursor position}
  123.   MOV BH, 0    { On page 0 }
  124.   Int 10h      { Return inFormation in DX }
  125.   Inc DH       { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
  126.   MOV AL, DH   { Return Y position in AL For use in Byte Result }
  127. END;
  128.  
  129. PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER;
  130. (* Routine from SWAG *)
  131. ASM
  132.   MOV DH, Y    { DH = Row (Y) }
  133.   MOV DL, X    { DL = Column (X) }
  134.   Dec DH       { Adjust For Zero-based Bios routines }
  135.   Dec DL       { Turbo Crt.GotoXY is 1-based }
  136.   MOV BH, 0    { Display page 0 }
  137.   MOV AH, 2    { Call For SET CURSOR POSITION }
  138.   Int 10h
  139. END;
  140.  
  141. PROCEDURE WriteCharAtCursor (X: CHAR);
  142. (* Routine from SWAG *)
  143. VAR
  144.   reg: REGISTERS;
  145. BEGIN
  146.   reg. AH := $0A;
  147.   reg. AL := Ord (X);
  148.   reg. BH := $00;    {* Display Page Number. * for Graphics Modes! *}
  149.   reg. CX := 1;      {* Word for number of characters to write *}
  150.   Intr ($10, reg);
  151. END;
  152.  
  153. PROCEDURE ClrEol;
  154. (* Routine by DDA *)
  155. VAR
  156.   NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
  157.   X, Y, DistanceToRight: BYTE;
  158. BEGIN
  159.   X := WhereX;
  160.   Y := WhereY;
  161.   DistanceToRight := NumCol - X;
  162.   Write ('': DistanceToRight);
  163.   WriteCharAtCursor (#32);
  164.   GotoXY (X, Y);
  165. END;
  166.  
  167. FUNCTION LeadingZero (w : WORD) : STRING;
  168. VAR
  169.   s : STRING;
  170. BEGIN
  171.   Str (w: 0, s);
  172.   IF Length (s) = 1 THEN
  173.     s := '0' + s;
  174.   LeadingZero := s;
  175. END;
  176.  
  177. PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  178. INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  179.         $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  180.  
  181. FUNCTION Upper (lstr : STRING): STRING;
  182. BEGIN
  183.   upfast (lstr);
  184.   Upper := lstr;
  185. END;
  186.  
  187. FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
  188. BEGIN
  189.   WHILE (Length (bstr) < len) DO
  190.     bstr := bstr + #32;
  191.   RPad := bstr;
  192. END;
  193.  
  194. FUNCTION RTrim (InStr: STRING): STRING;
  195. BEGIN
  196.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
  197.     Dec (InStr [0]);
  198.   RTrim := InStr;
  199. END;
  200.  
  201. FUNCTION LTrim (InStr: STRING): STRING;
  202. BEGIN
  203.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  204.     Delete (InStr, 1, 1);
  205.   LTrim := InStr;
  206. END;
  207.  
  208. FUNCTION Squeeze (ss: STRING): STRING;
  209. VAR
  210.   controlCHAR: CHAR;
  211. BEGIN
  212.   FOR controlCHAR := #0 TO #31 DO
  213.     WHILE (Ord (ss [0]) > 0) AND (Pos (controlCHAR, ss) > 0) DO
  214.       ss [Pos (controlCHAR, ss)] := #32;
  215.   Squeeze := RTrim (LTrim (ss));
  216. END;
  217.  
  218. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  219. VAR
  220.   Attr  : WORD;
  221.   cFile : FILE;
  222. BEGIN
  223.   Assign (cFile, FileName);
  224.   GetFAttr (cFile, Attr);
  225.   IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
  226.     THEN IsFile := TRUE
  227.     ELSE IsFile := FALSE;
  228. END;
  229.  
  230. PROCEDURE EraseFile (CONST FileName : STRING);
  231. VAR
  232.   cFile : FILE;
  233. BEGIN
  234.   IF IsFile (FileName) THEN BEGIN
  235.     Assign (cFile, FileName);
  236.     SetFAttr (cFile, 0);
  237.     Erase (cFile); CheckIO;
  238.   END;
  239. END;
  240.  
  241. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  242. VAR
  243.   Attr  : WORD;
  244.   cFile : FILE;
  245. BEGIN
  246.   Assign (cFile, FileName);
  247.   GetFAttr (cFile, Attr);
  248.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  249.     THEN IsDir := TRUE
  250.     ELSE IsDir := FALSE;
  251. END;
  252.  
  253. FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
  254. VAR
  255.   jPath     : PATHSTR;  { file path,       }
  256.   jDir      : DIRSTR;   {      directory,  }
  257.   jName     : NAMESTR;  {      name,       }
  258.   jExt      : EXTSTR;   {      extension.  }
  259. BEGIN
  260.   jPath := PSTR;
  261.   IF jPath = '' THEN jPath := '*.*';
  262.   IF (NOT (jPath [L